home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Language/OS - Multiplatform Resource Library
/
LANGUAGE OS.iso
/
pcl
/
cl-nd-cl.lha
/
clue
/
clio
/
slider.lisp
< prev
next >
Wrap
Text File
|
1990-07-19
|
46KB
|
1,115 lines
;; -*- Mode:Lisp; Package:CLIO-OPEN; Base:10; Lowercase:T; Fonts:(CPTFONT); Syntax:Common-Lisp; -*-
;;;----------------------------------------------------------------------------------+
;;; |
;;; TEXAS INSTRUMENTS INCORPORATED |
;;; P.O. BOX 149149 |
;;; AUSTIN, TEXAS 78714 |
;;; |
;;; Copyright (C) 1989, 1990 Texas Instruments Incorporated. |
;;; |
;;; Permission is granted to any individual or institution to use, copy, modify, and |
;;; distribute this software, provided that this complete copyright and permission |
;;; notice is maintained, intact, in all copies and supporting documentation. |
;;; |
;;; Texas Instruments Incorporated provides this software "as is" without express or |
;;; implied warranty. |
;;; |
;;;----------------------------------------------------------------------------------+
(in-package "CLIO-OPEN")
(export '(
make-slider
slider
)
'clio-open)
(defmacro translate-x-to-y (x x-width slider)
"Translate x coord for horizontal slider into y of a vertical slider.
X-WIDTH is the width in x-direction that must be changed into a y-offset."
`(with-slots (height) ,slider
(- height 1 ,x (max 0 (1- ,x-width)))))
(defmacro confine-to (value minimum maximum)
`(max ,minimum (min ,value ,maximum)))
(defmacro align (value increment)
;; Since we are talking SCALE VALUE here
;; we pixel-round since it may be a REAL number.
`(if (= 1 ,increment)
,value
(* (pixel-round ,value ,increment) ,increment)))
(defmacro value-length (value minimum)
`(- ,value ,minimum))
;;;----------------------------------------------------------------------------+
;;; |
;;; Slider |
;;; |
;;;----------------------------------------------------------------------------+
;; Implementation Strategy:
;;
;; Since CLIO should implement a "look and
;; feel" independent implemementation of open-look, then only those
;; parts of the slider that are going to exist in most implemementations
;; will be supported. Since make-slider accepts :
;; (increment indicator-size maximum minimum orientation update-delay value compress-exposures)
;; then all "features" must be derived from these inputs.
;;
;; To provide numeric visual feedback of the current value is desirable,
;; but providing this as a typein field or read-only field really requires a label
;; or else the displayed result is somewhat confusing.
;; The current value will be implemented as AUTOMATIC tick-marks and tick-mark
;; labels based on the min-max values and the space available to print them. The
;; actual current value will not be printed but will be discernable by "reading the scale".
;;
;; Thus the slider parts implemented are :
;; (bar, drag-box, (automatic) tick-marks, (automatic) tick-text)
;; and the following will NOT be provided :
;; (End boxes, labels, typein fields, non-numeric text of any kind)
;; This means that the read-only min-max current-value fields will be provided only by way
;; of the min-/max tick-mark tick-text labels.
;;
;; When horizontal sliders require max (or min) values of more than 2 digits
;; then the tick-mark & tick-mark-number-labels are difficult to display. In this
;; case a :vertical orientation is more appropriate. If more than 2-digits are used
;; for a :horizontal slider then the tick-mark granularity will be reduced in order
;; to accommodate the width of the digits.
;;
(defcontact slider (core contact)
((increment :type number
:reader scale-increment ;; SETF method defined below
:initarg :increment
:initform 1)
(indicator-size ;; The size of the distance between tick-marks in value units.
;; :off means "no tickmarks or tick labels", 1 will cause tick-mark
;; overlap if there is not enough space to display. [2..N] will
;; cause a tick-spacing of [1..(1- N)].
;;
:type (or number (member :off)) ;; 0 means "automatic" tick mark spacing.
:reader scale-indicator-size ;; SETF method defined below
:initarg :indicator-size
:initform 0)
(maximum :type number
:reader scale-maximum ;; SETF method defined below
:initarg :maximum
:initform 1)
(minimum :type number
:reader scale-minimum ;; SETF method defined below
:initarg :minimum
:initform 0)
(orientation :type (member :horizontal :vertical)
:reader scale-orientation ;; SETF method defined below
:initarg :orientation
:initform :horizontal)
(update-delay :type (or number (member :until-done))
:reader scale-update-delay ;; SETF method defined below
:initarg :update-delay
:initform 0)
(value :type number
:reader scale-value ;; SETF method defined below
:initarg :value
:initform 0)
(compress-exposures
:initform :on
:type (member :off :on)
:reader contact-compress-exposures
:allocation :class)
;; Internal storage slots
(font :type fontable);; font for current scale
(min-text-width :type number) ;; pixel width of minimum value print string
(max-text-width :type number) ;; pixel width of maximum value print string
(dimensions :type list) ;; (getf *slider-dimensions* scale)
(middle-length :type number) ;; pixel length between first & last tick marks
)
(:resources
increment indicator-size maximum minimum orientation update-delay value
(border-width :initform 0)
(event-mask :initform #.(make-event-mask :exposure :pointer-motion-hint))))
;;;----------------------------------------------------------------------------+
;;; |
;;; Setf Accessors |
;;; |
;;;----------------------------------------------------------------------------+
(defmethod (setf scale-orientation) (new-orientation (slider slider))
(with-slots (orientation width height) slider
(unless (eq orientation new-orientation)
(check-type new-orientation (member :horizontal :vertical))
(setf orientation new-orientation)
(multiple-value-bind (new-width new-height)
(preferred-size slider :width height :height width)
(change-geometry slider :width new-width :height new-height :accept-p t))))
new-orientation)
(defmethod (setf scale-update-delay) (new-update-delay (slider slider))
(with-slots (update-delay) slider
(assert (or (eq new-update-delay :until-done)
(and (numberp new-update-delay) (not (minusp new-update-delay)))) (new-update-delay)
"~a is neither :UNTIL-DONE or a non-negative number." new-update-delay)
(setf update-delay new-update-delay)))
(defmethod (setf scale-value) (new-value (slider slider))
(scale-update slider :value new-value)
new-value)
(defmethod (setf scale-minimum) (new-minimum (slider slider))
(scale-update slider :minimum new-minimum)
new-minimum)
(defmethod (setf scale-maximum) (new-maximum (slider slider))
(scale-update slider :maximum new-maximum)
new-maximum)
(defmethod (setf scale-increment) (new-increment (slider slider))
(scale-update slider :increment new-increment)
new-increment)
(defmethod (setf scale-indicator-size) (new-indicator-size (slider slider))
(scale-update slider :indicator-size new-indicator-size)
new-indicator-size)
;;;------------------------------------------------------------------------------------+
;;; |
;;; Helper Functions |
;;; |
;;;------------------------------------------------------------------------------------+
(defun slider-tick-mark-thickness (slider)
(if (eq :extra-large (contact-scale slider))
3
2))
(defun slider-bar-tick-gap (slider)
;; Distance top of tick-mark and nearest point on bar
(1+ (case (contact-scale slider)
(:small 1) (:medium 2) (:large 3) (:extra-large 4))))
(defun slider-margin (slider margin)
"Returns the MARGIN of SLIDER, one of :min :top :text :max"
;; This is initially *slider-default-margin* until
;; after the PREFERRED-SIZE method is called. Then margins include
;; any additional increase due to a width or height larger than the
;; preferred size. :LEFT means the left margin for this particular orientation.
(assert (member margin '(:min :top :text :max)) (margin)
"~a is an illegal margin" margin)
(let ((margins (getf (getf (window-plist slider) :slider-info) :margins)))
(or (getf margins margin)
;; Calling before margins are setup is never
;; done but code is here for completeness
*slider-default-margin*)))
(defun first-tick-offset (slider)
;; Offset, not including (slider-margin slider :min), from
;; min edge of contact to CENTERLINE of first tick-mark.
(with-slots (min-text-width orientation font dimensions indicator-size) slider
(let ((tick-mark-offset (slidebar-tick-mark-offset dimensions))
(gap (slidebar-gap dimensions)))
(+ *slider-default-margin*
;; Add GAP below since drag-box clear-gap-around extends past bar edge
(if (eq :off indicator-size)
(+ gap tick-mark-offset)
(if (eq orientation :horizontal)
(max (floor min-text-width 2) (+ gap tick-mark-offset))
(+ gap tick-mark-offset) ;; the text baseline is ALWAYS above end of bar MIN
))))))
(defun last-tick-offset (slider)
;; Offset, not including (slider-margin slider :max), from
;; max edge of contact to CENTERLINE of last tick-mark.
(with-slots (max-text-width orientation font dimensions indicator-size) slider
(let ((tick-mark-offset (slidebar-tick-mark-offset dimensions))
(gap (slidebar-gap dimensions)))
(+ *slider-default-margin*
;; Add GAP below since drag-box clear-gap-around extends past bar edge
(if (eq :off indicator-size)
(+ gap tick-mark-offset)
(if (eq orientation :horizontal)
(max (ceiling max-text-width 2) (+ gap tick-mark-offset))
(+ tick-mark-offset
(max gap
;; font-ascent may go beyond end of bar MAX if font is bigger than "point" requested
(abs (- (cadr (getf (slidebar-bar-text-offset dimensions) orientation))
(max-char-ascent font)
))))))))))
;;
;;
;; Pixels : Scale Units :
;;
;; middle-length (- maximum minimum)
;;
;; [MAX]
;; |
;; |
;; | proportional [MAX]
;; | - |
;; | |
;; | Pixel-delta | -
;; | | Scale-delta
;; | |
;; [MIN] - [MIN] -
;;
;; 0 minimum
;;
;; Since :
;;
;; pixel-delta / middle-length = scale-delta / (- maximum minimum)
;;
;; Then :
;;
;; Pixel-delta = (* scale-delta middle-length) / (- maximum minimum)
;;
;; And :
;;
;; Scale-delta = (* pixel-delta (- maximum minimum)) / middle-length
;;
(defun units-to-pixels (slider scale-delta)
;; Convert a scale delta to a pixel delta
(with-slots (minimum maximum middle-length) slider
(pixel-round (/ (* scale-delta middle-length)
(- maximum minimum)))))
(defun pixels-to-units (slider pixel-delta)
(with-slots (orientation minimum maximum increment middle-length) slider
;; Convert a pixel delta to a scale units delta
;; *DON'T* round this - units may be fractional !
(/ (* pixel-delta (- maximum minimum))
middle-length)))
;; NOTE: The functions named ????-x and below return values strictly for a :horizontal
;; slider and the return values must be translated for a :vertical slider.
(defun first-tick-x (slider)
(+ (slider-margin slider :min)
(first-tick-offset slider)))
(defun drag-box-center-x (slider &optional (scale-value (scale-value slider)))
(with-slots (minimum) slider
;; Returns dead center of drag-box
(+ (first-tick-x slider)
;; Must subtract minimum since minimum can be negative and is NOT always zero!
(units-to-pixels slider (value-length scale-value minimum)))))
(defun drag-box-min-x (slider &optional (scale-value (scale-value slider)))
(with-slots (dimensions minimum maximum) slider
(let* ((drag-box-width (slidebar-drag-box-width dimensions))
(gap (slidebar-gap dimensions)))
(- (drag-box-center-x slider scale-value)
(floor drag-box-width 2)
gap ;; subtract whitespace gap around drag-box
))))
(defun drag-box-position (slider &optional (scale-value (scale-value slider)))
(declare (values x y width height))
(with-slots (orientation ) slider
;; Return values describing area of drag-box for SCALE-VALUE
(let* ((drag-min-edge (drag-box-min-x slider scale-value))
(drag-image (getf (getf *slider-drag-box-images* orientation)
(contact-scale slider))))
(if (eq orientation :horizontal)
(values drag-min-edge
(+ (slider-margin slider :top) *slider-default-margin*)
(image-width drag-image)
(image-height drag-image))
(values (+ (slider-margin slider :top) *slider-default-margin*)
(translate-x-to-y drag-min-edge (image-height drag-image) slider)
(image-width drag-image)
(image-height drag-image)))
)))
(defmethod scale-update ((slider slider) &key value minimum maximum indicator-size increment)
;; Called by (method initialize-instance :after (slider)) to do error checking, and by
;; SETF methods for slots in arglist above, and by (setf scale-value) called to move slider.
(with-slots
((current-val value)
(current-min minimum)
(current-max maximum)
(current-ind indicator-size)
(current-inc increment)
orientation min-text-width max-text-width font)
slider
(let ((old-val (and value current-val)) ;; old-value & flag that value was passed in.
(old-min (and minimum current-min))
(old-max (and maximum current-max))
(old-inc (and increment current-inc))
(old-ind (and indicator-size current-ind)))
(setf minimum (or minimum current-min)
maximum (or maximum current-max)
value (or value (confine-to current-val minimum maximum))
indicator-size (or indicator-size current-ind)
increment (or increment current-inc))
(assert (and (numberp minimum) (numberp maximum)
(< minimum maximum))
(minimum maximum)
"Minimum (~a) is not less than maximum (~a)."
minimum maximum)
(assert (and (numberp value)
(<= minimum value maximum))
(value)
"Value (~a) must be in the range [~a, ~a]."
value minimum maximum)
(assert (or (eq :off indicator-size)
(and (numberp indicator-size)
(not (minusp indicator-size))))
(indicator-size)
"Indicator-size (~a) must be :OFF, 0, or a positive number."
indicator-size)
(assert (and (numberp increment)
(< 0 increment (1+ (- maximum minimum))) ;; allow fractional increments, allow increment = maximum
(zerop (mod (- maximum minimum) increment)))
(increment)
"Increment (~a) must be in the range [0 ~a] and a factor of ~:*~d."
increment (- maximum minimum))
;; Once VALUE & INCREMENT are valid we can align VALUE, if necessary,
;; to be a multiple of INCREMENT.
(setq value (+ minimum (align (value-length value minimum) increment)))
(setf current-min minimum
current-max maximum
current-val value
current-ind indicator-size
current-inc increment
min-text-width (text-extents font (format nil "~a" minimum))
max-text-width (text-extents font (format nil "~a" maximum)))
;; Redisplay drag-box and any changes
(when (realized-p slider)
(cond ((or (and old-min
(not (= old-min current-min)))
(and old-max
(not (= old-max current-max)))
(and old-ind
(not (eq old-ind current-ind)))
(and old-inc
(not (= old-inc current-inc))))
(clear-area slider :exposures-p t))
((and old-val ;; when called with NEW increment value
(not (= old-val current-val))) ;; when something has changed
;; Compute area of old drag-box ( if any )
(multiple-value-bind (old-x old-y old-width old-height)
(drag-box-position slider old-val)
;; Compute area of new drag-box
(multiple-value-bind (x y width height)
(drag-box-position slider current-val)
;; Merge areas to redisplay : new drag-box, bar between old & new,
;; old drag-box ( if any ), & tick marks obscured by drag-box
(when old-val
(if (eq orientation :horizontal)
(setf width (+ (abs (- x old-x)) (max old-width width))
x (min x old-x))
(setf height (+ (abs (- y old-y)) (max old-height height))
y (min y old-y))))
(clear-area slider :x x :y y :width width :height height)
(display slider x y width height))))
(t)))
)))
;;;----------------------------------------------------------------------------+
;;; |
;;; Initialization |
;;; |
;;;----------------------------------------------------------------------------+
(defun make-slider (&rest initargs &key &allow-other-keys)
(apply #'make-contact 'slider initargs))
(defun bar-bottom-offset (slider)
;; Offset from the top (left) of horizontal (vertical) slider
;; ... does NOT include (slider-margin slider :top) ...
;; and 1-pixel past the bottom (right) edge of the slidebar
(with-slots (dimensions) slider
(+ *slider-default-margin*
(slidebar-gap dimensions)
(slidebar-bar-drag-offset dimensions)
(slidebar-bar-thickness dimensions))))
(defun fixed-thickness (slider &key include-text-p)
;; The minimum thickness of slider required for the
;; scale, orientation, and string characteristics of the minimum & maximum
(with-slots (orientation min-text-width max-text-width
indicator-size dimensions font) slider
(let ((x (first (getf (slidebar-bar-text-offset dimensions) orientation)))
(y (second (getf (slidebar-bar-text-offset dimensions) orientation)))
(scale (contact-scale slider)))
(if (eq :off indicator-size)
(+ *slider-default-margin*
(if (eq orientation :horizontal)
(image-height (getf (getf *slider-drag-box-images* orientation) scale))
(image-width (getf (getf *slider-drag-box-images* orientation) scale)))
*slider-default-margin*) ;; no space allocated for tick marks & text
;; else
(if (eq orientation :horizontal)
(+ (bar-bottom-offset slider) y
(if include-text-p
(+ (max-char-descent font) *slider-default-margin*)
0))
(+ (bar-bottom-offset slider) x
(if include-text-p
(+ (max min-text-width max-text-width) *slider-default-margin*)
0)))))))
(defun slider-compute-margins (slider)
;; Now margins can be computed from the delta between the size needed and the
;; size we were given. The length of the slider basically stretches to fit but
;; any extra height results in the slider being centered in space provided.
;; PREFERRED-SIZE (via initialize-instance :after) MUST have been called to
;; set WIDTH & HEIGHT by this time.
(with-slots (orientation width height middle-length) slider
(let* ((total-min-thickness (fixed-thickness slider :include-text-p t))
(size (if (eq orientation :horizontal) height width))
(top-margin (floor (- size total-min-thickness) 2))
(bottom-margin (- size total-min-thickness top-margin)))
(setf (getf (getf (window-plist slider) :slider-info) :margins)
;; left top bottom right (horizontal)
(list :min 0 :top top-margin :text bottom-margin :max 0))
;; With margins set we can now compute and save middle-length for efficiency
(setf middle-length
(- (if (eq :horizontal orientation)
width
height)
(slider-margin slider :min)
(first-tick-offset slider)
(last-tick-offset slider)
(slider-margin slider :max)
)))))
(defmethod initialize-instance :after ((slider slider) &key &allow-other-keys)
(with-slots (font width height minimum maximum
dimensions min-text-width max-text-width) slider
(setq font (find-font slider *default-display-text-font*)
dimensions (getf *slider-dimensions* (contact-scale slider)))
(scale-update slider) ;; do some error checking, set min-text-width, etc.
;; Initialize required geometry
(multiple-value-setq (width height) (preferred-size slider))
;; Compute margins now that WIDTH & HEIGHT are known
(slider-compute-margins slider)
))
;;;----------------------------------------------------------------------------+
;;; |
;;; Geometry Management |
;;; |
;;;----------------------------------------------------------------------------+
(DEFMETHOD rescale :before ((slider slider))
(with-slots (font dimensions) slider
(setf font (find-font slider *default-display-text-font*)
dimensions (getf *slider-dimensions* (contact-scale slider)))
(slider-compute-margins slider)
))
(defmethod resize :after ((slider slider) new-width new-height new-border-width)
;; This method duplicates calculations started in (method initialize-instance :after (slider))
;; but are done here since they also must be performed when change-geometry is invoked.
;; Called when window-manager or someone else calls change-geometry.
(declare (ignore new-width new-height new-border-width))
(slider-compute-margins slider))
(defmethod preferred-size ((slider slider) &key width height border-width)
(declare (ignore border-width)) ;; preferred-border-width is 0
(with-slots (orientation min-text-width max-text-width font dimensions indicator-size
(current-height height) (current-width width)) slider
(let* ((drag-box-width (slidebar-drag-box-width dimensions))
(tick-mark-offset (slidebar-tick-mark-offset dimensions))
;; Min width of slider with 2 positions = double size of drag box
(minimum-double-width
(+ (- (first-tick-offset slider) tick-mark-offset)
(max (* 2 drag-box-width)
(if (eq :off indicator-size)
0
(if (eq orientation :horizontal)
;; room needed to display text between first/last-tick
(+ (ceiling min-text-width 2)
(max-char-descent font)
(floor max-text-width 2))
;; room needed to display 2 text lines (min & max) vertically,
;; plus a small gap between
(+ (max-char-ascent font)
(max-char-descent font) ;; gap between
(max-char-ascent font)))))
(- (last-tick-offset slider) tick-mark-offset)))
;; Calculate geometry assuming :horizontal orientation
(preferred-height
(max
;; Suggested or current height
(if (eq orientation :horizontal)
(or height current-height)
(or width current-width))
;; Total thickness of horizontal bar
(fixed-thickness slider :include-text-p t)))
(preferred-width
(max
;; Suggested or current width
(if (eq orientation :horizontal)
(or width current-width)
(or height current-height))
minimum-double-width))
)
;; Return preferred geometry according to actual orientation
(if (eq orientation :horizontal) ;; preferred-border-width is always 0
(values preferred-width preferred-height 0)
(values preferred-height preferred-width 0))
)))
;;;----------------------------------------------------------------------------+
;;; |
;;; Event Translations |
;;; |
;;;----------------------------------------------------------------------------+
(defevent slider (:button-press :button-1) slider-press)
(defevent slider (:button-release :button-1) slider-release)
(defevent slider (:motion-notify :button-1) slider-handle-motion)
(defun slider-release (slider)
(declare (special *slider-pressed-p*))
(when (boundp '*slider-pressed-p*)
(throw-action slider :release t)))
(defun highlite-drag-box (slider gc x y width height gap)
(draw-rectangle slider gc (+ gap 1 gap x) (+ gap 1 gap y)
(- width (* 4 gap) 3) (- height (* 4 gap) 3) :fill-p))
(defun slider-press (slider)
(with-event (x y)
(with-slots
(foreground orientation update-delay minimum maximum
increment width height display value dimensions)
slider
(let (*slider-pressed-p* )
(declare (special *slider-pressed-p*))
(multiple-value-bind (drag-x drag-y drag-width drag-height)
(drag-box-position slider)
(when
(cond
((and (>= x drag-x) (< x (+ drag-x drag-width))
(>= y drag-y) (< y (+ drag-y drag-height)))
;; SELECT on drag box
(let ((*highlight-pixel* (logxor foreground (contact-current-background-pixel slider)))
(gap (slidebar-gap dimensions)))
(declare (special *highlight-pixel*)) ;; use this in display method while moving ..
(using-gcontext
(gc :drawable slider
:function boole-xor
:foreground *highlight-pixel*)
;; Highlight drag area
(highlite-drag-box slider gc drag-x drag-y drag-width drag-height gap)
;; Set timer for update
(when (and (numberp update-delay) (plusp update-delay))
(add-timer slider :update-delay update-delay))
(apply-callback slider :begin-continuous)
(catch :release
(let ((*previous-position* (if (eq :vertical orientation) y x)))
(declare (special *previous-position*))
(loop (process-next-event display))))
(apply-callback slider :end-continuous)
;; Unhighlight drag area.
(multiple-value-bind (new-drag-x new-drag-y)
(drag-box-position slider)
(highlite-drag-box slider gc new-drag-x new-drag-y drag-width drag-height gap))))
t)
;; SELECT on bar
;; Since it is NOT in drag-box, just check if it is in bar
;; or the area of the bar if it had the thickness of the drag-box.
;; This makes clicking somewhat easier.
((multiple-value-bind (bar-x bar-y bar-width bar-height)
(if (eq orientation :horizontal)
(values (slider-margin slider :min) (slider-margin slider :top)
(- width (slider-margin slider :min) (slider-margin slider :max))
drag-height)
(values (slider-margin slider :top) (slider-margin slider :min)
drag-width
(- height (slider-margin slider :min) (slider-margin slider :max))))
(and (>= x bar-x) (>= y bar-y)
(< x (+ bar-x bar-width))
(< y (+ bar-y bar-height))))
;; Advance drag-box one increment in direction indicated.
;; User may click so fast that the drag box passes the click
;; position, thus inadvertently reversing the increment direction.
;; Synchronize by using current pointer position, not click position.
(multiple-value-bind (ptr-x ptr-y) (pointer-position slider)
(let ((delta (if (if (eq orientation :horizontal)
(< ptr-x drag-x)
(>= ptr-y (+ drag-y drag-height)))
(- increment)
increment))
(gap (slidebar-gap dimensions)))
(slider-increment-value slider delta)
;; Must warp pointer to stay in MIN (or MAX) bar, if necessary
(multiple-value-bind (new-drag-x new-drag-y drag-width drag-height)
(drag-box-position slider)
(multiple-value-bind (warp-x warp-y)
(if (eq orientation :horizontal)
(if (plusp delta)
(let ((min-x (min (1- width) (+ new-drag-x drag-width gap))))
(when (< ptr-x min-x)
(values min-x ptr-y)))
(let ((max-x (max 0 (- new-drag-x gap))))
(when (< max-x ptr-x)
(values max-x ptr-y))))
(if (minusp delta)
(let ((min-y (min (1- height) (+ new-drag-y drag-height gap))))
(when (< ptr-y min-y)
(values ptr-x min-y)))
(let ((max-y (max 0 (- new-drag-y gap))))
(when (< max-y ptr-y)
(values ptr-x max-y)))))
(when warp-x
(warp-pointer slider warp-x warp-y))))))
t))
;; Report final value, if necessary
(unless (eql 0 update-delay)
(delete-timer slider :update-delay)
(apply-callback slider :new-value value))))))))
(defun slider-increment-value (slider scale-increment)
"Convert the scale-increment to a (possibly) new scale position
and (possibly) cause the slider to be updated."
(with-slots (value orientation increment minimum maximum update-delay) slider
;; Must use truncate for negative scale-increment's - rounds to zero.
(let* ((new-value (+ value scale-increment))
(adjusted (confine-to (or (apply-callback slider :adjust-value new-value)
new-value)
minimum maximum)))
(unless (= value adjusted) ;; unless no change in slider scale occurs
(setf (scale-value slider) adjusted) ;; <- this calls scale-update & redisplays slider
(when (eql 0 update-delay)
(apply-callback slider :new-value adjusted))))))
(defun slider-handle-motion (slider)
(declare (special *previous-position*))
(when (boundp '*previous-position*)
(with-slots (orientation increment) slider
(with-event (state x y)
(multiple-value-bind (ptr-x ptr-y)
;; Is :button-1 still down?
(if (plusp (logand state #.(make-state-mask :button-1)))
;; Yes, query current pointer position
(pointer-position slider)
;; No, use final x,y returned for button transition
(values x y))
(let
((modulo-increment
(* (truncate
(pixels-to-units
slider
(if (eq :horizontal orientation)
(- ptr-x *previous-position*)
;; Must swap order of subtraction since positive y direction
;; is negative scale direction for :vertical slider
(- *previous-position* ptr-y)))
increment)
increment)))
;; Convert the pixel motion to a suitable slider scale motion
(unless (zerop modulo-increment)
(slider-increment-value slider modulo-increment)
;; Use drag-box position. Ptr position is only correct if the drag-box can
;; move to the ptr posiiton without bumping up against the min/max limits.
(setf *previous-position*
(if (eq orientation :horizontal)
(drag-box-center-x slider)
(translate-x-to-y (drag-box-center-x slider) 1 slider))
))))))))
(defun choose-indicator-size (slider)
"Returns TICK-LIMIT = the number of ticks to draw."
;; Called when indicator-size eq :off to automatic tick-marks
(declare (values tick-limit increments-in-tick))
(with-slots (maximum minimum increment) slider
(let* ((tick-mark-thickness (slider-tick-mark-thickness slider))
(increments-in-tick 1)
(min-visible-width (* 2 tick-mark-thickness))
(ticks (floor (- maximum minimum) increment))
)
;; Return appropriate tick-limit
(values
(1+ ;; 1+ since we draw the first-tick plus any calculated ticks
(do* ((ticks-visible nil))
((cond
((<= ticks 1) (setq ticks-visible 1)) ;; reached minimum ticks, 1 at each end
((>= (units-to-pixels slider (* increments-in-tick increment))
min-visible-width)
(setq ticks-visible ticks)))
;; Exit form
(return ticks-visible))
(setq ticks (floor ticks 2)
increments-in-tick (* 2 increments-in-tick))))
increments-in-tick ;; 2nd return value
))))
;;;----------------------------------------------------------------------------+
;;; |
;;; Display |
;;; |
;;;----------------------------------------------------------------------------+
;;; d1 = first-tick-x
;;; d2 = slidebar-tick-mark-offset
;;;
;;; min fill drag empty max
;;; +-----------------------------------+ -
;;; | | gap
;;; | +----+ | -
;;; | | || | drag-bar-offset
;;; | .-- ----- | || -------- --. | -
;;; | |** ***** | || | | bar-thickness
;;; | `-- ----- | || -------- --' | -
;;; | |---+| |
;;; |<-----> +----+ |
;;; | d1 || || || | bar-text-offset
;;; | <--> |
;;; | d2 |
;;; | MIN MAX |
;;; +-----------------------------------+ -
;;; ^^ ^ ^ ^ ^^ ^
;;; || | | | || +-- bar-max-x
;;; || | | | |+---- (<= last-tick-x MAX-UPPER-EDGE bar-max-x)
;;; || | | | +----- last-tick-x
;;; || | | +------------- drag-max-edge
;;; || | +--------------------- drag-min-edge
;;; || +--------------------------- first-tick-x
;;; |+----------------------------- (<= bar-min-x MIN-LOWER-EDGE first-tick-x )
;;; +------------------------------ bar-min-x
;;;
;;; Note: No margins are shown except *slider-default-margin*
;;;
;;;
;;; .--.
;;; | | max
;;;
;;; | |
;;; | |
;;; | | empty
;;; | |
;;;
;;; +----+
;;; | |
;;; | | drag
;;; | |
;;; +----+
;;;
;;; |**|
;;; |**| fill
;;; |**|
;;; |**|
;;;
;;; |**| min
;;; `--'
;;;
(defmethod display ((slider slider) &optional at-x at-y at-width at-height &key)
(with-slots (dimensions width height foreground orientation
minimum maximum increment middle-length sensitive
min-text-width max-text-width indicator-size font) slider
;; Default exposed rectangle, if necessary
(setf at-x (or at-x 0)
at-y (or at-y 0)
at-width (or at-width (- width at-x))
at-height (or at-height (- height at-y)))
(let* ((drag-box-width (slidebar-drag-box-width dimensions))
(drag-bar-offset (slidebar-bar-drag-offset dimensions))
(gap (slidebar-gap dimensions))
(bar-thickness (slidebar-bar-thickness dimensions))
(bar-image (getf (getf *slider-bar-images* :masks) (contact-scale slider)))
(image-half-size (floor (image-width bar-image) 2)) ;; image is BOTH ends, use min half
(first-tick-x (first-tick-x slider))
(last-tick-x (+ first-tick-x middle-length))
(bar-y (+ (slider-margin slider :top) *slider-default-margin*
gap drag-bar-offset))
(bar-min-x (- first-tick-x ;; ZRP
(slidebar-tick-mark-offset dimensions)))
(bar-max-x (+ last-tick-x (slidebar-tick-mark-offset dimensions)))
(drag-min-edge (drag-box-min-x slider))
(drag-max-edge (+ drag-min-edge gap drag-box-width gap))
(end-portion (min image-half-size (max 0 (- drag-min-edge bar-min-x)))) ;; for min end ONLY
(min-lower-edge (+ bar-min-x end-portion))
(max-upper-edge (max (- bar-max-x image-half-size) drag-max-edge))
(mask (contact-image-mask slider bar-image
:foreground foreground
:background (contact-current-background-pixel slider)))
(inactive-p (not (sensitive-p slider)))
(scale (contact-scale slider))
)
;; First draw the bar outline, then
;; draw the tick-marks, draw the tick-text, and
;; finally, fill the bar then blt the drag-box to the correct position.
(using-gcontext (gc :drawable slider
:font font
:exposures :off
:foreground (if inactive-p
(logxor foreground (contact-current-background-pixel slider))
foreground)
:fill-style (when inactive-p :stippled)
:function (when inactive-p boole-xor)
;; Use 50%gray, since 25%gray looks bad (bar disappears) for args :
;; (make-slider :width 200 :height 200 :maximum 4 :orientation :vertical :scale :medium)
:stipple (when inactive-p (contact-image-mask slider 50%gray :depth 1))
:clip-mask (list at-x at-y at-width at-height)
)
;; Draw MIN end - if it will be visible after drag-box is drawn later.
;; The zero reference point (ZRP) is the center of the first tick-mark.
;; If at this position we just draw the drag-box at ZRP after subtracting
;; the half-width of the drag-box to get the coordinate of the left edge.
;; Actually the image blt to the slider also contains a gap, but the ZRP is
;; situated such that it centers the drag-box at the extreme min position.
;; Draw (at least part of) MIN
(when (> drag-min-edge bar-min-x) ;; drag-box is NOT less than gap away from MIN edge
(multiple-value-bind (src-x src-y -width -height dst-x dst-y)
(if (eq orientation :horizontal)
(values 0 0 end-portion (image-width bar-image) bar-min-x bar-y)
(values 0 (- (image-width bar-image) image-half-size) ;; image may have odd # of pixels
(image-width bar-image) end-portion
bar-y (translate-x-to-y bar-min-x end-portion slider)))
(when (area-overlaps-p at-x at-y at-width at-height dst-x dst-y -width -height)
(if inactive-p
(draw-rectangle slider gc dst-x dst-y -width -height :fill-p)
(copy-area mask gc src-x src-y -width -height slider dst-x dst-y))))
;; Draw FILL, if any
(when (> drag-min-edge min-lower-edge)
(multiple-value-bind (x y -width -height)
(if (eq orientation :horizontal)
(values min-lower-edge bar-y (- drag-min-edge min-lower-edge) bar-thickness)
(values bar-y (translate-x-to-y min-lower-edge (- drag-min-edge min-lower-edge) slider)
bar-thickness (- drag-min-edge min-lower-edge)))
(when (area-overlaps-p at-x at-y at-width at-height x y -width -height)
(draw-rectangle slider gc x y -width -height :fill-p))))
)
;; Draw EMPTY portion, if any
(when (> max-upper-edge drag-max-edge)
(multiple-value-bind (x y x2 y2 x3 y3 x4 y4)
(if (eq orientation :horizontal)
(values drag-max-edge bar-y ;; x y
max-upper-edge bar-y ;; x2 y2
drag-max-edge (+ bar-y bar-thickness -1) ;; x3 y3
max-upper-edge (+ bar-y bar-thickness -1)) ;; x4 y4
(values bar-y (translate-x-to-y drag-max-edge 1 slider) ;; x y
bar-y (translate-x-to-y max-upper-edge 1 slider) ;; x2 y2
(+ bar-y bar-thickness -1) (translate-x-to-y drag-max-edge 1 slider) ;; x3 y3
(+ bar-y bar-thickness -1) (translate-x-to-y max-upper-edge 1 slider))) ;; x4 y4
(when (area-overlaps-p at-x at-y at-width at-height x y (- x2 x) bar-thickness)
(draw-segments slider gc (list x y x2 y2 x3 y3 x4 y4))))
)
;; Draw MAX, or portion not obscured by drag-box
(when (plusp (setq end-portion (min image-half-size (- bar-max-x max-upper-edge))))
(setq mask (contact-image-mask slider (getf (GETF *slider-bar-images* :borders) scale)
:foreground foreground
:background (contact-current-background-pixel slider)))
(multiple-value-bind (src-x src-y -width -height dst-x dst-y)
(if (eq orientation :horizontal)
(values (- (image-width bar-image) end-portion) 0
end-portion (image-width bar-image)
max-upper-edge bar-y)
(values 0 0
(image-width bar-image) end-portion
bar-y (translate-x-to-y max-upper-edge end-portion slider)))
(when (area-overlaps-p at-x at-y at-width at-height dst-x dst-y -width -height)
(if inactive-p
(draw-rectangle slider gc dst-x dst-y -width -height :fill-p)
(copy-area mask gc src-x src-y -width -height slider dst-x dst-y))))
)
;; Draw TICK-TEXT, the labels for MIN and MAX
(unless (eq :off indicator-size) ;; don't draw tick marks or tick text
(let ((min-thickness (+ (slider-margin slider :top)
(fixed-thickness slider :include-text-p nil)))
(text-x-offset (first (getf (slidebar-bar-text-offset dimensions) orientation)))
(text-y-offset (second (getf (slidebar-bar-text-offset dimensions) orientation))))
(multiple-value-bind (x-min y-min x-max y-max)
(if (eq orientation :horizontal)
(values (+ (slider-margin slider :min)
text-x-offset
;; center text at :first-tick
(+ (first-tick-offset slider)
(- (floor min-text-width 2))))
min-thickness
(- width
(slider-margin slider :max)
(last-tick-offset slider)
(ceiling max-text-width 2)) ;; scoot left to fit on odd widths!
min-thickness)
(values min-thickness
(+ (slider-margin slider :max)
(last-tick-offset slider)
middle-length
(slidebar-tick-mark-offset dimensions)
(- gap))
min-thickness
(+ (slider-margin slider :max)
(last-tick-offset slider)
(- (slidebar-tick-mark-offset dimensions))
text-y-offset)))
(let* ((font-ascent (max-char-ascent font))
(font-height (+ font-ascent (max-char-descent font))))
(when (if (eq orientation :horizontal)
(area-overlaps-p at-x at-y at-width at-height
x-min (- y-min font-ascent)
(+ (- x-max x-min) max-text-width)
font-height)
(area-overlaps-p at-x at-y at-width at-height
x-max (- y-max font-ascent)
(max min-text-width max-text-width)
(+ (- y-min y-max) font-height)))
;; Draw TICK-TEXT for min and max
(draw-glyphs slider gc x-min y-min (format nil "~a" minimum))
(draw-glyphs slider gc x-max y-max (format nil "~a" maximum))))))
;; Draw TICK-MARKS
(multiple-value-bind (tick-limit increments-in-tick)
(if (plusp indicator-size)
(values (1+ (floor (- maximum minimum) (* increment indicator-size)))
indicator-size)
(choose-indicator-size slider)) ;; automatic tick marks
(do* ((tick 0 (incf tick))
(tick-thickness (slider-tick-mark-thickness slider))
(tick-x (+ (first-tick-x slider) (- (floor tick-thickness 2))) ;; adjust from center to edge of tick
(+ (first-tick-x slider) (- (floor tick-thickness 2))
(units-to-pixels slider (* tick increments-in-tick increment))))
(tick-y (+ (slider-margin slider :top)
(bar-bottom-offset slider)
(slider-bar-tick-gap slider)))
(tick-height (slidebar-tick-mark-length dimensions)))
((= tick tick-limit)) ;; draw tick @min plus TICK-LIMIT more
(multiple-value-bind (x y -width -height)
(if (eq orientation :horizontal)
(values tick-x tick-y
tick-thickness tick-height)
(values tick-y (translate-x-to-y tick-x tick-thickness slider)
tick-height tick-thickness))
(when (area-overlaps-p at-x at-y at-width at-height x y -width -height)
(draw-rectangle slider gc x y -width -height :fill-p)
))))
)
;; Draw DRAG BOX (possibly over a tick mark)
(let ((drag-image (getf (getf *slider-drag-box-images* orientation) scale)))
(setq mask (contact-image-mask slider drag-image
:foreground foreground
:background (contact-current-background-pixel slider)))
(multiple-value-bind (src-x src-y -width -height dst-x dst-y)
(if (eq orientation :horizontal)
(values 0 0 (image-width drag-image) (image-height drag-image)
drag-min-edge (- bar-y drag-bar-offset gap))
(values 0 0 (image-width drag-image) (image-height drag-image)
(- bar-y drag-bar-offset gap)
(translate-x-to-y drag-min-edge (image-height drag-image) slider)))
(when (area-overlaps-p at-x at-y at-width at-height
dst-x dst-y -width -height)
(if inactive-p
(draw-rectangle slider gc dst-x dst-y -width -height :fill-p)
(copy-area mask gc src-x src-y -width -height slider dst-x dst-y))
(when (boundp '*highlight-pixel*)
(special-highlite-drag-box slider gc dst-x dst-y -width -height gap)))))))))
;;; Crock! This function could be inlined, except that causes the Explorer compiler
;;; to barf on (method display (slider)) when using R4 CLX.
(defun special-highlite-drag-box (slider gc dst-x dst-y -width -height gap)
(declare (special *highlight-pixel*))
(with-gcontext (gc :function boole-xor :foreground *highlight-pixel*)
;; Highlight drag area while button is still down )
(highlite-drag-box slider gc dst-x dst-y -width -height gap)))
